home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / c / main.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-05-07  |  18.4 KB  |  1,021 lines
  1. /*
  2.  Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  3.  
  4. This file is part of GNU Common Lisp, herein referred to as GCL
  5.  
  6. GCL is free software; you can redistribute it and/or modify it under
  7. the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  8. the Free Software Foundation; either version 2, or (at your option)
  9. any later version.
  10.  
  11. GCL is distributed in the hope that it will be useful, but WITHOUT
  12. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13. FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  14. License for more details.
  15.  
  16. You should have received a copy of the GNU Library General Public License 
  17. along with GCL; see the file COPYING.  If not, write to the Free Software
  18. Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. */
  21.  
  22. /*
  23.     main.c
  24.     IMPLEMENTATION-DEPENDENT
  25. */
  26.  
  27. #define IN_MAIN
  28.  
  29. #ifdef KCLOVM
  30. #include <ovm/ovm.h>
  31. void change_contexts();
  32. int ovm_process_created; 
  33. void initialize_process();
  34. #endif
  35.  
  36. #include "include.h"
  37. #ifdef UNIX
  38. #include <signal.h>
  39.  
  40. int segmentation_catcher();
  41. #endif
  42. #include "page.h"
  43.  
  44. bool saving_system = FALSE;
  45.  
  46. #ifdef BSD
  47. #include <sys/time.h>
  48. #ifndef SGI
  49. #include <sys/resource.h>
  50. #endif
  51. #endif
  52.  
  53. #ifdef AOSVS
  54.  
  55. #endif
  56.  
  57. #define    MAXPATHLEN    1024
  58.  
  59. char lisp_implementation_version[] = "April 1994";
  60.  
  61. char system_directory[MAXPATHLEN];
  62.  
  63. int page_multiple=1;
  64.  
  65. char stdin_buf[BUFSIZ];
  66. char stdout_buf[BUFSIZ];
  67.  
  68. int debug;            /* debug switch */
  69. int initflag = FALSE;        /* initialized flag */
  70.  
  71. int real_maxpage;
  72. object siVlisp_maxpages;
  73.  
  74. object siClisp_pagesize;
  75.  
  76. object siStop_level;
  77.  
  78.  
  79. static object defmacro_data;
  80. static object evalmacros_data;
  81. static object top_data;
  82. static object module_data;
  83. static object siLmultiply_stacks;
  84. int stack_multiple=1;
  85. static object stack_space;
  86.  
  87. char *merge_system_directory();
  88.  
  89. int cssize;
  90.  
  91. int sgc_enabled;
  92. void install_segmentation_catcher();
  93.  
  94. #define SIG_STACK_SIZE 1000
  95. #ifndef SETUP_SIG_STACK
  96. #if defined(HAVE_SIGACTION) || defined(HAVE_SIGVEC)
  97.         struct sigstack estack;
  98. #endif
  99. #endif
  100.  
  101. main(argc, argv, envp) 
  102. int argc;
  103. char **argv, **envp;
  104. {
  105.     FILE *i;
  106. #ifdef BSD
  107. #ifndef SGI
  108.     struct rlimit rl;
  109. #endif
  110. #endif
  111. #if defined(HAVE_SIGACTION) || defined(HAVE_SIGVEC)
  112.  
  113. #ifdef SETJMP_ONE_DIRECTION
  114.     static
  115. #endif
  116.       /* make sure the stack is 8 byte aligned */
  117.     double estack_buf[SIG_STACK_SIZE];
  118. #endif
  119.     setbuf(stdin, stdin_buf);
  120.     setbuf(stdout, stdout_buf);
  121.  
  122.     ARGC = argc;
  123.     ARGV = argv;
  124. #ifdef UNIX
  125.     ENVP = envp;
  126. #endif
  127.  
  128. #ifdef UNIX
  129. /*
  130.     if (argv[0][0] != '/')
  131.         error("can't get the program name");
  132. */
  133.     kcl_self = argv[0];
  134.     if (!initflag) {
  135.         strcpy(system_directory, argv[0]);
  136.         if (system_directory[0] != '/')
  137.             strcpy(system_directory, "./");
  138.         else {
  139.             int j;
  140.  
  141.             for (j = strlen(system_directory);
  142.                              system_directory[j-1] != '/';  --j)
  143.                 ;
  144.             system_directory[j] = '\0';
  145.         }
  146.     }
  147. #endif
  148. #ifdef AOSVS
  149.  
  150.  
  151.  
  152.  
  153.  
  154.  
  155.  
  156.  
  157.  
  158.  
  159.  
  160.  
  161. #endif
  162.  
  163.     if (!initflag && argc > 1) {
  164. #ifdef UNIX
  165.         if (argv[1][strlen(argv[1])-1] != '/')
  166. #endif
  167. #ifdef AOSVS
  168.  
  169. #endif
  170.             error("can't get the system directory");
  171.         strcpy(system_directory, argv[1]);
  172.     }
  173.  
  174.     GBC_enable = FALSE;
  175.  
  176.     /* if stack_space not zero we have grown the stack space */
  177.     if (stack_space == 0)
  178.       {
  179.         vs_org = value_stack;
  180.         vs_limit = &vs_org[VSSIZE];
  181.         frs_org = frame_stack;
  182.         frs_limit = &frs_org[FRSSIZE];
  183.         bds_org = bind_stack;
  184.         bds_limit = &bds_org[BDSSIZE];
  185. #ifdef KCLOVM
  186.         bds_save_org = save_bind_stack;
  187.         bds_save_top = bds_save_org - 1;
  188.         bds_save_limit = &bds_save_org[BDSSIZE];
  189. #endif
  190.         ihs_org = ihs_stack;
  191.         ihs_limit = &ihs_org[IHSSIZE];}
  192.  
  193.     vs_top = vs_base = vs_org;
  194.     clear_stack(vs_top,vs_limit);
  195.     ihs_top = ihs_org-1;
  196.     bds_top = bds_org-1;
  197.     frs_top = frs_org-1;
  198.     cs_org = &argc;
  199.  
  200.     cssize = CSSIZE;
  201.     install_segmentation_catcher();
  202.  
  203. #ifdef BSD
  204. #ifdef RLIMIT_STACK
  205.     getrlimit(RLIMIT_STACK, &rl);
  206.     cssize = rl.rlim_cur/4 - 4*CSGETA;
  207. #endif    
  208. #endif
  209.  
  210. #ifdef AV
  211.     cs_limit = cs_org - cssize;
  212. #endif
  213. #ifdef MV
  214.  
  215. #endif
  216.         
  217.     set_maxpage();
  218. #ifdef SETUP_SIG_STACK
  219.     SETUP_SIG_STACK
  220. #else
  221. #if defined(HAVE_SIGACTION) || defined(HAVE_SIGVEC)
  222.     bzero(estack_buf,sizeof(estack_buf));
  223.     estack.ss_sp = (char *) &estack_buf[SIG_STACK_SIZE-1];
  224.     estack.ss_onstack=0;
  225.     sigstack(&estack,0);
  226. #endif    
  227. #endif    
  228.     
  229.  
  230.     if (initflag) {
  231.         if (saving_system) {
  232.             saving_system = FALSE;
  233.             alloc_page(-(holepage + nrbpage));
  234.         }
  235.  
  236.         initflag = FALSE;
  237.         GBC_enable = TRUE;
  238.         vs_base = vs_top;
  239.         ihs_push(Cnil);
  240.         lex_new();
  241.         vs_base = vs_top;
  242. #ifdef AOSVS
  243.  
  244.  
  245. #endif
  246.         interrupt_enable = TRUE;
  247. #ifdef UNIX
  248.         init_interrupt();
  249. #endif
  250.         siVlisp_maxpages->s.s_dbind = make_fixnum(real_maxpage);
  251.         initflag = TRUE;
  252. #ifdef KCLOVM
  253.         ovm_user_context_change = change_contexts;
  254.         ovm_user_context_initialize = initialize_process;
  255.  
  256.         v_init_processes();
  257.         ovm_process_created = 1;
  258. #endif
  259.           again:
  260.         super_funcall(siStop_level);
  261.         if (type_of(siLmultiply_stacks->s.s_dbind)==t_fixnum)
  262.           {multiply_stacks(fix(siLmultiply_stacks->s.s_dbind));
  263.            goto  again;}
  264.  
  265.         exit(0);
  266.     }
  267.  
  268.     printf("GCL (GNU Common Lisp)  %s  %d pages\n",
  269.            lisp_implementation_version,
  270.            MAXPAGE);
  271.     fflush(stdout);
  272.  
  273.     initlisp();
  274.  
  275.     vs_base = vs_top;
  276.     ihs_push(Cnil);
  277.     lex_new();
  278.  
  279.     GBC_enable = TRUE;
  280.  
  281.     CMPtemp = CMPtemp1 = CMPtemp2 = CMPtemp3 = OBJNULL;
  282.  
  283.     init_init();
  284.  
  285.     Vpackage->s.s_dbind = user_package;
  286.  
  287.     lex_new();
  288.     vs_base = vs_top;
  289.     initflag = TRUE;
  290.  
  291.     interrupt_enable = TRUE;
  292. #ifdef UNIX
  293.     init_interrupt();
  294. #endif
  295.  
  296. /*  Primitive read-eval-print loop for debugging.  */
  297. /*
  298.     for (;;) {
  299.         vs_base = vs_top;
  300.         vs_push(code_char('>'));
  301.         Lwrite_char();
  302.         vs_base = vs_top;
  303.         Lfinish_output();
  304.         vs_base = vs_top;
  305.         Lread();
  306.         Leval();
  307.         vs_top = vs_base+1;
  308.         Lprin1();
  309.         vs_base = vs_top;
  310.         Lterpri();
  311.     }
  312. */
  313.  
  314. /*  Now, init.lsp is loaded by si:top-level.  */
  315. /*
  316. #ifdef UNIX
  317.     if ((i = fopen("./init.lsp", "r")) != NULL) {
  318.         fclose(i);
  319.         load("./init.lsp");
  320.     }
  321. #endif
  322. #ifdef AOSVS
  323.  
  324.  
  325.  
  326.  
  327. #endif
  328. */
  329.  
  330.     super_funcall(siStop_level);
  331.  
  332. }
  333.  
  334.  
  335. void
  336. gcl_signal(signo,handler)
  337.      int signo;
  338.      void (*handler)();
  339. {
  340. #ifdef HAVE_SIGACTION
  341.   struct sigaction action;
  342.   action.sa_handler = handler;
  343.   action.sa_flags = SA_RESTART | (signo == SIGSEGV || signo == SIGBUS ? SV_ONSTACK : 0)
  344. #ifdef SA_SIGINFO
  345.     | SA_SIGINFO
  346. #endif      
  347.     ;
  348.   sigemptyset(&action.sa_mask);
  349.   sigaddset(&action.sa_mask,signo);
  350.   sigaction(signo,&action,0);
  351. #else
  352. #ifdef HAVE_SIGVEC
  353.   struct sigvec vec;
  354.   vec.sv_handler =  handler;
  355.   vec.sv_flags =  (signo == SIGSEGV || signo == SIGBUS ? SV_ONSTACK : 0);
  356.   vec.sv_mask = sigmask(signo);
  357.   sigvec(signo,&vec,0);
  358. #else
  359.   signal(signo,handler);
  360. #endif
  361. #endif  
  362. }
  363.  
  364.  
  365. /* catch certain signals */
  366. void install_segmentation_catcher()
  367. {
  368. #ifdef INSTALL_SEGMENTATION_CATCHER
  369.   INSTALL_SEGMENTATION_CATCHER;
  370. #else
  371. #ifdef SIGSEGV
  372.        (void) gcl_signal(SIGSEGV,segmentation_catcher);
  373. #endif
  374. #endif
  375.        }
  376.  
  377.  
  378.  
  379. initlisp()
  380. {
  381.     int j;
  382.  
  383.     init_alloc();
  384.  
  385.     Cnil_body.t = (short)t_symbol;
  386.     Cnil_body.s_dbind = Cnil;
  387.     Cnil_body.s_sfdef = NOT_SPECIAL;
  388.     Cnil_body.s_fillp = 3;
  389.     Cnil_body.s_self = "NIL";
  390.     Cnil_body.s_gfdef = OBJNULL;
  391.     Cnil_body.s_plist = Cnil;
  392.     Cnil_body.s_hpack = Cnil;
  393.     Cnil_body.s_stype = (short)stp_constant;
  394.     Cnil_body.s_mflag = FALSE;
  395.     
  396.     Ct_body.t = (short)t_symbol;
  397.     Ct_body.s_dbind = Ct;
  398.     Ct_body.s_sfdef = NOT_SPECIAL;
  399.     Ct_body.s_fillp = 1;
  400.     Ct_body.s_self = "T";
  401.     Ct_body.s_gfdef = OBJNULL;
  402.     Ct_body.s_plist = Cnil;
  403.     Ct_body.s_hpack = Cnil;
  404.     Ct_body.s_stype = (short)stp_constant;
  405.     Ct_body.s_mflag = FALSE;
  406.     
  407.     init_symbol();
  408.  
  409.     init_package();
  410.  
  411.     Cnil->s.s_hpack = lisp_package;
  412.     import(Cnil, lisp_package);
  413.     export(Cnil, lisp_package);
  414.  
  415.     Ct->s.s_hpack = lisp_package;
  416.     import(Ct, lisp_package);
  417.     export(Ct, lisp_package);
  418.  
  419.     Squote = make_ordinary("QUOTE");
  420.     enter_mark_origin(&Squote);
  421.     Sfunction = make_ordinary("FUNCTION");
  422.     enter_mark_origin(&Sfunction);
  423.     Slambda = make_ordinary("LAMBDA");
  424.     enter_mark_origin(&Slambda);
  425.     Slambda_block = make_ordinary("LAMBDA-BLOCK");
  426.     enter_mark_origin(&Slambda_block);
  427.     Slambda_closure = make_ordinary("LAMBDA-CLOSURE");
  428.     enter_mark_origin(&Slambda_closure);
  429.     Slambda_block_closure = make_ordinary("LAMBDA-BLOCK-CLOSURE");
  430.     enter_mark_origin(&Slambda_block_closure);
  431.     Sspecial = make_ordinary("SPECIAL");
  432.     enter_mark_origin(&Sspecial);
  433.  
  434.     init_typespec();
  435.     init_pari();
  436.     init_number();
  437.     init_character();
  438.     init_file();
  439.     init_read();
  440.     init_bind();
  441.     init_pathname();
  442.     init_print();
  443.     init_GBC();
  444.  
  445. #ifdef UNIX
  446. #ifndef DGUX
  447.     init_unixfasl();
  448.     init_unixsys();
  449.     init_unixsave();
  450. #else
  451.  
  452.  
  453.  
  454. #endif
  455. #endif
  456.  
  457.     init_alloc_function();
  458.     init_array_function();
  459.     init_character_function();
  460.     init_file_function();
  461.     init_list_function();
  462.     init_package_function();
  463.     init_pathname_function();
  464.     init_predicate_function();
  465.     init_print_function();
  466.     init_read_function();
  467.     init_sequence_function();
  468. #if  defined(KCLOVM) || defined(RUN_PROCESS)
  469.     init_socket_function();
  470. #endif    
  471.     init_structure_function();
  472.     init_string_function();
  473.     init_symbol_function();
  474.     init_typespec_function();
  475.     init_hash();
  476.     init_cfun();
  477.  
  478. #ifdef UNIX
  479.     init_unixfsys();
  480.     init_unixtime();
  481. #endif
  482.     init_eval();
  483.     init_lex();
  484.     init_prog();
  485.     init_catch();
  486.     init_block();
  487.         init_macros();
  488.     init_conditional();
  489.     init_reference();
  490.     init_assignment();
  491.     init_multival();
  492.     init_error();
  493.     init_let();
  494.     init_mapfun();
  495.     init_iteration();
  496.     init_toplevel();
  497.  
  498.     init_cmpaux();
  499.  
  500.     init_main();
  501.  
  502.     init_format();
  503.     init_links();
  504.  
  505.     init_fat_string();
  506. #ifdef CMAC
  507.     init_cmac();
  508. #endif    
  509.     init_interrupt1();
  510. }
  511.  
  512. /*  init_init is now defined in init_system.c  */
  513. /*
  514. init_init()
  515. {
  516.     load(merge_system_directory("export.lsp"));
  517.  
  518. #ifdef UNIX
  519.     defmacro_data = read_fasl_data(merge_system_directory("defmacro.o"));
  520.     enter_mark_origin(&defmacro_data);
  521.     init_defmacro(NULL, 0, defmacro_data);
  522.     evalmacros_data
  523.     = read_fasl_data(merge_system_directory("evalmacros.o"));
  524.     enter_mark_origin(&evalmacros_data);
  525.     init_evalmacros(NULL, 0, evalmacros_data);
  526.     top_data = read_fasl_data(merge_system_directory("top.o"));
  527.     enter_mark_origin(&top_data);
  528.     init_top(NULL, 0, top_data);
  529.     module_data = read_fasl_data(merge_system_directory("module.o"));
  530.     enter_mark_origin(&module_data);
  531.     init_module(NULL, 0, module_data);
  532. #endif
  533. #ifdef AOSVS
  534.  
  535.  
  536.  
  537.  
  538.  
  539.  
  540.  
  541.  
  542.  
  543.  
  544.  
  545.  
  546.  
  547.  
  548. #endif
  549.  
  550.     load(merge_system_directory("autoload.lsp"));
  551. }
  552. */
  553.  
  554. char *
  555. merge_system_directory(s)
  556. {
  557.     static char buff[MAXPATHLEN];
  558.     extern char *strcat();
  559.  
  560.     strcpy(buff, system_directory);
  561.     return(strcat(buff, s));
  562. }
  563.  
  564. vs_overflow()
  565. {
  566.     if (vs_limit > vs_org + stack_multiple *  VSSIZE)
  567.         error("value stack overflow");
  568.     vs_limit += VSGETA;
  569.     FEerror("Value stack overflow.", 0);
  570. }
  571.  
  572.  
  573. bds_overflow()
  574. {
  575.     --bds_top;
  576.     if (bds_limit > bds_org + stack_multiple *  BDSSIZE)
  577.         error("bind stack overflow");
  578.     bds_limit += BDSGETA;
  579.     FEerror("Bind stack overflow.", 0);
  580. }
  581.  
  582. frs_overflow()
  583. {
  584.     --frs_top;
  585.     if (frs_limit > frs_org + stack_multiple *  FRSSIZE)
  586.         error("frame stack overflow");
  587.     frs_limit += FRSGETA;
  588.     FEerror("Frame stack overflow.", 0);
  589. }
  590.  
  591. ihs_overflow()
  592. {
  593.     --ihs_top;
  594.     if (ihs_limit > ihs_org + stack_multiple *  IHSSIZE)
  595.         error("invocation history stack overflow");
  596.     ihs_limit += IHSGETA;
  597.     FEerror("Invocation history stack overflow.", 0);
  598. }
  599.  
  600. segmentation_catcher()
  601. {int x;
  602. #ifndef SIG_STACK_SIZE 
  603.  if (&x < cs_limit)
  604.     cs_overflow();
  605.  else 
  606.   {printf("Segmentation violation: c stack ok:signalling error");
  607.     }
  608. #endif
  609.   error("Segmentation violation.");
  610. }
  611.  
  612. cs_overflow()
  613. {
  614. #ifdef AV
  615.     if (cs_limit < cs_org - cssize)
  616.         error("control stack overflow");
  617.     cs_limit -= CSGETA;
  618. #endif
  619. #ifdef MV
  620.  
  621.  
  622.  
  623. #endif
  624.     FEerror("Control stack overflow.", 0);
  625. }
  626.  
  627. end_of_file()
  628. {
  629.     error("end of file");
  630. }
  631.  
  632.  
  633. int catch_fatal=1;
  634. error(s)
  635. {
  636.         if (catch_fatal>0 && interrupt_enable )
  637.       {catch_fatal = -1;
  638.        if (sgc_enabled)
  639.          { sgc_quit();}
  640.        if (sgc_enabled==0)
  641.          { install_segmentation_catcher() ;}
  642.        FEerror("Caught fatal error [memory may be damaged]"); }
  643.     printf("\nUnrecoverable error: %s.\n", s);
  644.     fflush(stdout);
  645. #ifdef UNIX
  646.     abort();
  647. #endif
  648. #ifdef AOSVS
  649.  
  650. #endif
  651. }
  652.  
  653. Lby()
  654. {
  655. #ifdef UNIX
  656.     int i;
  657.  
  658.     if (vs_top - vs_base == 0)
  659.         i = 0;
  660.     else if (vs_top - vs_base == 1) {
  661.         if (type_of(vs_base[0]) == t_fixnum)
  662.             i = fix(vs_base[0]);
  663.         else
  664.             FEerror("Illegal exit code: ~S.", 1, vs_base[0]);
  665.     } else
  666.         too_many_arguments();
  667.     printf("Bye.\n");
  668.     exit(i);
  669. #endif
  670. #ifdef AOSVS
  671.  
  672.  
  673.  
  674.  
  675.  
  676.  
  677.  
  678.  
  679.  
  680.  
  681.  
  682.  
  683.  
  684.  
  685.  
  686.  
  687.  
  688.  
  689.  
  690.  
  691.  
  692.  
  693. #endif
  694. }
  695.  
  696. c_trace()
  697. {
  698. #ifdef AOSVS
  699.  
  700. #endif
  701. }
  702.  
  703. siLargc()
  704. {
  705.     check_arg(0);
  706.     vs_push(make_fixnum(ARGC));
  707. }
  708.  
  709. siLargv()
  710. {
  711.     int i;
  712.  
  713.     check_arg(1);
  714.     if (type_of(vs_base[0]) != t_fixnum ||
  715.         (i = fix(vs_base[0])) < 0 ||
  716.         i >= ARGC)
  717.         FEerror("Illegal argument index: ~S.", 1, vs_base[0]);
  718.     vs_base[0] = make_simple_string(ARGV[i]);
  719. }
  720.  
  721. #ifdef UNIX
  722. siLgetenv()
  723. {
  724.     char name[256];
  725.     int i;
  726.     char *value;
  727.     extern char *getenv();
  728.  
  729.     check_arg(1);
  730.     check_type_string(&vs_base[0]);
  731.     if (vs_base[0]->st.st_fillp >= 256)
  732.         FEerror("Too long name: ~S.", 1, vs_base[0]);
  733.     for (i = 0;  i < vs_base[0]->st.st_fillp;  i++)
  734.         name[i] = vs_base[0]->st.st_self[i];
  735.     name[i] = '\0';
  736.     if ((value = getenv(name)) != NULL)
  737.         vs_base[0] = make_simple_string(value);
  738.     else
  739.         vs_base[0] = Cnil;
  740. }
  741. #endif
  742.  
  743. object *vs_marker;
  744.  
  745. siLmark_vs()
  746. {
  747.     check_arg(0);
  748.     vs_marker = vs_base;
  749.     vs_base[0] = Cnil;
  750. }
  751.  
  752. siLcheck_vs()
  753. {
  754.     check_arg(0);
  755.     if (vs_base != vs_marker)
  756.         FEerror("Value stack is flawed.", 0);
  757.     vs_base[0] = Cnil;
  758. }
  759.  
  760. object
  761. siLcatch_fatal(i)
  762. {catch_fatal=i;
  763.  return Cnil;}
  764.  
  765.  
  766. siLreset_stack_limits(arg)
  767. {
  768.     check_arg(0);
  769.     if(catch_fatal <0) catch_fatal=1;
  770. #ifdef SGC    
  771.     {extern int fault_count ; fault_count = 0;}
  772. #endif 
  773.     if (vs_top < vs_org + stack_multiple *  VSSIZE)
  774.         vs_limit = vs_org + stack_multiple *  VSSIZE;
  775.     else
  776.         error("can't reset vs_limit");
  777.     if (bds_top < bds_org + stack_multiple *  BDSSIZE)
  778.         bds_limit = bds_org + stack_multiple *  BDSSIZE;
  779.     else
  780.         error("can't reset bds_limit");
  781.     if (frs_top < frs_org + stack_multiple *  FRSSIZE)
  782.         frs_limit = frs_org + stack_multiple *  FRSSIZE;
  783.     else
  784.         error("can't reset frs_limit");
  785.     if (ihs_top < ihs_org + stack_multiple *  IHSSIZE)
  786.         ihs_limit = ihs_org + stack_multiple *  IHSSIZE;
  787.     else
  788.         error("can't reset ihs_limit");
  789. #ifdef AV
  790.     if (&arg > cs_org - cssize + 16)
  791.         cs_limit = cs_org - cssize;
  792. #endif
  793.     else
  794.         error("can't reset cs_limit");
  795.     vs_base[0] = Cnil;
  796. }
  797.  
  798. #define COPYSTACK(org,p,typ,lim,top,geta,size) \
  799.  do{int leng,topl;      \
  800.   bcopy(org,p,leng=(stack_multiple*size*sizeof(typ))); \
  801.   topl= top - org; \
  802.   org=(typ *)p; top = org +topl;\
  803.   p=p+leng+2*geta*sizeof(typ); \
  804.   lim = ((typ *)p) - 2*geta;   \
  805.   }while (0)
  806.  
  807. multiply_stacks(m)
  808.      int m;
  809. {  int n;
  810.    object x;
  811.    object gc_pro=stack_space;
  812.    char *p;
  813.    int vs,bd,frs,ihs;
  814.    stack_multiple=stack_multiple*m;
  815. #define ELTSIZE(x) (((char *)((x)+1)) - ((char *) x))
  816.    vs  = (stack_multiple*VSSIZE  + 2*VSGETA)* ELTSIZE(vs_org);
  817.    bd  = (stack_multiple*BDSSIZE + 2*BDSGETA)*ELTSIZE(bds_org);
  818.    frs = (stack_multiple*FRSSIZE + 2*FRSGETA)*ELTSIZE(frs_org);
  819.    ihs = (stack_multiple*IHSSIZE + 2*IHSGETA)*ELTSIZE(ihs_org);
  820.    if (stack_space==0) {enter_mark_origin(&stack_space);}
  821.    stack_space = alloc_simple_string(vs+bd+frs+ihs);
  822.    array_allocself(stack_space,1,code_char(0));
  823.    p=stack_space->st.st_self;
  824.    COPYSTACK(vs_org,p,object,vs_limit,vs_top,VSGETA,VSSIZE);
  825.    COPYSTACK(bds_org,p,struct bds_bd,bds_limit,bds_top,BDSGETA,BDSSIZE);
  826.    COPYSTACK(frs_org,p,struct frame,frs_limit,frs_top,FRSGETA,FRSSIZE);
  827.    COPYSTACK(ihs_org,p,struct invocation_history,ihs_limit,ihs_top,
  828.          IHSGETA,IHSSIZE);
  829.    vs_base=vs_top;
  830.    return stack_multiple;
  831.  }
  832.  
  833.  
  834.  
  835.  
  836.  
  837.  
  838.  
  839.   
  840.  
  841. siLinit_system()
  842. {
  843.     check_arg(0);
  844.     init_system();
  845.     vs_base[0] = Cnil;
  846. }
  847.  
  848. siLaddress()
  849. {
  850.     check_arg(1);
  851.     vs_base[0] = make_fixnum((int)vs_base[0]);
  852. }
  853.  
  854. siLnani()
  855. {
  856.     check_arg(1);
  857.     vs_base[0] = (object)fixint(vs_base[0]);
  858. }
  859.  
  860. siLinitialization_failure()
  861. {
  862.     check_arg(0);
  863.     printf("lisp initialization failed\n");
  864.     exit(0);
  865. }
  866.  
  867. Lidentity()
  868. {
  869.     check_arg(1);
  870. }
  871.  
  872. Llisp_implementation_version()
  873. {
  874.     check_arg(0);
  875.     vs_push(make_simple_string(lisp_implementation_version));
  876.     vs_base[0] = Cnil;
  877. }
  878.  
  879.  
  880. siLsave_system()
  881. {
  882.     int i;
  883.  
  884. #ifdef HAVE_YP_UNBIND
  885.     extern object truename(),namestring();
  886.     check_arg(1);
  887.     /* prevent subsequent consultation of yp by getting
  888.        truename now*/
  889.     vs_base[0]=namestring(truename(vs_base[0]));
  890.     {char name[200];
  891.      char *dom = name;
  892.      if (0== getdomainname(dom,sizeof(name)))
  893.        yp_unbind(dom);}
  894. #endif
  895.     
  896.     saving_system = TRUE;
  897.     GBC(t_contiguous);
  898.  
  899.  
  900.  
  901. #if defined(BSD) || defined(ATT)  
  902.     brk(core_end);
  903.   /* printf( "(breaking at core_end = %x in main ,)",core_end); */
  904. #endif
  905.  
  906. #ifdef DGUX
  907.  
  908. #endif
  909.  
  910. #ifdef AOSVS
  911.  
  912.  
  913.  
  914.  
  915. #endif
  916.     cbgbccount = 0;
  917.     rbgbccount = 0;
  918.     for (i = 0;  i < (int)t_end;  i++)
  919.         tm_table[i].tm_gbccount = 0;
  920.     Lsave();
  921.     saving_system = FALSE;
  922.     alloc_page(-(holepage+nrbpage));
  923. }
  924.  
  925. init_main()
  926. {
  927.     make_function("BY", Lby);
  928.     make_function("BYE", Lby);
  929.  
  930.     make_function("IDENTITY", Lidentity);
  931.  
  932.     siStop_level=make_si_ordinary("TOP-LEVEL");
  933.     enter_mark_origin(&siStop_level);
  934.  
  935.     make_si_function("ARGC", siLargc);
  936.     make_si_function("ARGV", siLargv);
  937.  
  938. #ifdef UNIX
  939.     make_si_function("GETENV", siLgetenv);
  940. #endif
  941.  
  942.     make_si_function("MARK-VS", siLmark_vs);
  943.     make_si_function("CHECK-VS", siLcheck_vs);
  944.  
  945.     make_si_function("RESET-STACK-LIMITS", siLreset_stack_limits);
  946.  
  947.     make_si_function("INIT-SYSTEM", siLinit_system);
  948.  
  949.     make_si_function("ADDRESS", siLaddress);
  950.     make_si_function("NANI", siLnani);
  951.  
  952.     make_si_function("INITIALIZATION-FAILURE",
  953.              siLinitialization_failure);
  954.  
  955.     make_function("LISP-IMPLEMENTATION-VERSION",
  956.               Llisp_implementation_version);
  957.  
  958.     siVlisp_maxpages =
  959.     make_si_special("*LISP-MAXPAGES*", make_fixnum(real_maxpage));
  960.  
  961.     siClisp_pagesize =
  962.     make_si_constant("LISP-PAGESIZE", make_fixnum(PAGESIZE));
  963.  
  964.     siVsystem_directory =
  965.     make_si_special("*SYSTEM-DIRECTORY*",
  966.             make_simple_string(system_directory));
  967.     {object features;
  968.  
  969. #define ADD_FEATURE(name) \
  970.      features=  make_cons(make_ordinary(name),features)
  971.  
  972.        features=    make_cons(make_ordinary("COMMON"),
  973.              make_cons(make_ordinary("KCL"), Cnil));
  974.      ADD_FEATURE("AKCL");
  975.      ADD_FEATURE("GCL");     
  976.  
  977. #ifdef UNIX
  978.     ADD_FEATURE("UNIX");
  979. #endif
  980. #ifdef IEEEFLOAT
  981.        ADD_FEATURE("IEEE-FLOATING-POINT");
  982. #endif
  983. #ifdef SGC
  984.        ADD_FEATURE("SGC");
  985. #endif     
  986. #ifdef  ADDITIONAL_FEATURES
  987.                       ADDITIONAL_FEATURES;
  988. #endif
  989. #ifdef  BSD
  990.     ADD_FEATURE("BSD");
  991. #endif
  992.  
  993.  
  994. #ifndef PECULIAR_MACHINE
  995. #define BIGM    (int)((((unsigned int)(-1))/2))     
  996.     { 
  997.       int ONEM = -1;
  998.       int Bigm  = BIGM;
  999.       int Smallm = -BIGM-1;
  1000.       int Seven = 7;
  1001.       int Three = 3;
  1002.       if ( (Smallm / Seven)  < 0
  1003.           && (Smallm / (-Seven))  > 0
  1004.           && (Bigm / (-Seven)) < 0 
  1005.           && ((-Seven) / Three) == -2
  1006.           && (Seven / (-Three)) == -2
  1007.           && ((-Seven)/ (-Three)) == 2)
  1008.         { ADD_FEATURE("TRUNCATE_USE_C");
  1009.         }  }
  1010. #endif     
  1011.  
  1012.  
  1013.      
  1014.     make_special("*FEATURES*",features);}
  1015.  
  1016.     make_si_function("SAVE-SYSTEM", siLsave_system);
  1017.     make_si_sfun("CATCH-FATAL",siLcatch_fatal,ARGTYPE1(f_fixnum));
  1018.     siLmultiply_stacks=make_si_special("*MULTIPLY-STACKS*",Cnil);
  1019.     
  1020. }
  1021.